perm filename EXPR.SAI[PNT,HE]17 blob
sn#469145 filedate 1979-08-29 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00012 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 ENTRY
C00004 00003 ! miscellaneous definitions
C00008 00004 ! expression builders: exp,bfact,bterm,aexp,term,factor,pfactor
C00016 00005 ! expression builders: hash,hashindex,new_expr,check_expr
C00018 00006 ! expression builders: opcode, idcode, cncode,arcode,prcode
C00029 00007 ! mkexpr,gtexpr,aref,idref,pref
C00033 00008 ! buffer definitions, ipush,fpush,gpush,ppush,cpush
C00035 00009 ! αexpr$,βexpr$,nexpr,expr$11,expr$2,expr$off
C00041 00010 ! $append,$aappend
C00044 00011 ! $$gtidref,$$gtanyexp
C00047 00012 ! $$gtexpr,$$gtvexpr
C00048 ENDMK
C⊗;
ENTRY;
BEGIN "EXPR"
DEFINE $$PRGID=TRUE; DEFINE $EXPR=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
REQUIRE "[][]" DELIMITERS;
DEFINE TOKEN_INDEX = [TOKENINDEX],TOKEN_CLASS=[tokenclass],ID_CLASS=[TOKEN_INDEX];
! miscellaneous definitions ;
PRELOAD_WITH "SCALAR","VECTOR","ROT","TRANS","FRAME","EVENT";
STRING ARRAY DTYPES[1:6];
COMMENT TEMPORARY EXPR RECORD USED INTERNALLY BY THESE ROUTINES;
RCLASS !!EXPR(INTEGER OP,X1,X2; INTEGER TYPE,#EL; RPTR(!!EXPR)SON,BRO);
! OP is opcode, x1,x2 are used to represent floating point numbers in 11 format
x1 along is used for index of array
x2 is used for leveloffset of array;
INTEGER ##EL;
INTEGER BRCHAR,SPBR;
REDEFINE ZZ(ARG0,ARG1,ARG2)=[ARG0,] ;
preload_array(CODE_OP, OP_LIST,STRING, 1, #PNTINTOPS);
REDEFINE ZZ(ARG0,ARG1,ARG2)=[ARG2,];
preload_array(CODE_LEVEL,OP_LIST,INTEGER,1,#PNTINTOPS);
REDEFINE XXCOUNT=0;
REDEFINE ZZ(ARG1,ARG2,ARG3)=[];
REDEFINE XXX(ARGNAME,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[
REDEFINE XXCOUNT=XXCOUNT + 1;];
OP_LIST;
DEFINE XXARG=0;
REDEFINE ZZ(ARG1,ARG2,ARG3)=[ REDEFINE XXARG=XXARG + 1;];
REDEFINE XXX(ARGNAME,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[
REDEFINE XXVAL = ((((XXARG*#DTYPE)+ARG1)*#DTYPE+ARG2)*#DTYPE+ARG3);
XXVAL,
];
DEFINE #HASHTAB=XXCOUNT;
preload_array(HASHTAB, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGTYPE,ARGORDER,ARG1,AR2,ARG)=[
IFCR ¬DECLARATION(ARGNAME) THENC
REQUIRE "UNDEFINED OP:: "&CVPS(ARGNAME)&"
" MESSAGE;
ENDC];
OP_LIST;
REDEFINE XXX(ARGNAME,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[
IFCR ¬DECLARATION(ARGNAME) THENC
MAKEOP(ARGNAME)
ENDC ARGNAME,];
preload_array(PCODE, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[ARGTYPE,];
preload_array(OPTYPE, OP_LIST, INTEGER, 1, #HASHTAB);
PROCEDURE GGTOKEN(BOOLEAN FLAG(TRUE));
α INTEGER I;
GTOKEN(FLAG);
FOR I←1 STEP 1 UNTIL #PNTINTOPS
DO IF EQU(TOKEN,CODE_OP[I])
THEN BEGIN
#TOKEN←OPERATOR_TYPE;
TOKEN_CLASS←CODE_LEVEL[I];
TOKEN_INDEX←I;
RETURN;
END;
IF EQU(TOKEN,0) THEN #TOKEN←UNDECLARED_TYPE;
β;
FORWARD RPTR (!!EXPR) PROCEDURE OPCODE(INTEGER OP,NARGS; RPTR(!!EXPR)EPTR);
FORWARD RPTR (!!EXPR) PROCEDURE CNCODE(REAL VAL);
FORWARD RPTR (!!EXPR) PROCEDURE IDCODE(RPTR(SYMBOL)SYMPTR);
FORWARD RECURSIVE RPTR (!!EXPR) PROCEDURE ARCODE(RPTR(SYMBOL)PTR;INTEGER OPERATION(XGTVAL));
FORWARD RECURSIVE RPTR(!!EXPR)PROCEDURE VPRCODE(RPTR(SYMBOL)PRSYM);
! expression builders: exp,bfact,bterm,aexp,term,factor,pfactor;
! EXP E: BF { OR BF }
BFACT BF: BT { AND BT }
BTERM BT: AE | AE <REL> AE
AEXP AE: {+|-} T {+|- T }
TERM T: F {*|/ F}
FACTOR F: PF or PF↑PF
PFACTOR PF: ( E ) or | E | or func(E,E,E,..) or <constant> or <id> or ¬ PF;
DEFINE EXP= [XXXXX(EXP_XX)];
! FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE EXP XXXXX(EXP_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BEFACT XXXXX(BEFACT_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BFACT XXXXX(BFACT_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BTERM XXXXX(BTERM_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE AEXP XXXXX(AEXP_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE TERM XXXXX(TERM_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE FACTOR XXXXX(FACTOR_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE PF XXXXX(PF_XX);
RECURSIVE RPTR(!!EXPR) PROCEDURE XXXXX(INTEGER LEVEL);
α RPTR(!!EXPR)$$1,$$2,$$3; INTEGER I,I2;
CASE LEVEL OF
α
[BEFACT_XX] [BFACT_XX] [AEXP_XX] [TERM_XX]
α
IF LEVEL=AEXP_XX AND #TOKEN=OPERATOR_TYPE
AND TOKEN_CLASS= AEXP_XX THEN
α I←TOKEN_INDEX;
GGTOKEN; $$1←XXXXX(LEVEL + 1);
$$1←OPCODE(I,1,$$1);
β
ELSE $$1←XXXXX(LEVEL+1);
WHILE #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS=LEVEL DO
α I←TOKEN_INDEX;
GGTOKEN; !!EXPR:BRO[$$1] ← XXXXX(LEVEL + 1);
$$1←OPCODE(I,2,$$1);
β;
β;
[EXP_XX] [BTERM_XX] [FACTOR_XX]
α
$$1←XXXXX(LEVEL + 1);
IF (#TOKEN=OPERATOR_TYPE OR #TOKEN=RES_TYPE) AND TOKEN_CLASS=LEVEL
THEN
α I←TOKEN_INDEX;
GGTOKEN; !!EXPR:BRO[$$1]←XXXXX(LEVEL + 1);
$$1←OPCODE(I,2,$$1);
β;
β;
[PF_XX]
CASE #TOKEN OF
α "CASE #TOKEN"
[REAL_TYPE]
[INT_TYPE]
α INTEGER I;
$$1←CNCODE(REALSCAN(TOKEN,I)); GGTOKEN(FALSE); β;
[ID_TYPE]
α
CASE SYMBOL:ACCESS[TOKENPTR] OF
α
[#SIMPLE] $$1←IDCODE(TOKENPTR);
[#ARRAY] $$1←ARCODE(TOKENPTR);
[#PROCEDURE] $$1←VPRCODE(TOKENPTR)
β;
GGTOKEN(FALSE); β ;
[OPERATOR_TYPE]
CASE TOKEN_INDEX OF
α "CASE TOKEN_INDEX"
[LPAREN_X]
α "LPAREN_X"
GGTOKEN; $$2←$$1←EXP; I2←1;
IF TOKEN≠")"
THEN WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP;
I2←I2+1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")" THEN
ERROR("MISMATCHED PAREN")
ELSE GGTOKEN(FALSE);
IF I2≠1 THEN $$1←OPCODE(IMPLICIT_X,I2,$$1);
β "LPAREN_X";
[MAGNITUDE_X]
α GGTOKEN; $$1←EXP;
IF TOKEN="|"
THEN GGTOKEN(FALSE)
ELSE ERROR("MISMATCHED VERT BAR");
$$1←OPCODE(MAGNITUDE_X,1,$$1);
β;
[STOS_X][DOWNARROW_X][DOLLAR_X][ALPHA_X]
α INTEGER I; I←TOKEN_INDEX;
GGTOKEN; $$1←EXP;
$$1←OPCODE(I,1,$$1);
β;
ELSE
α I←TOKEN_INDEX; IF TOKEN_CLASS≠LEVEL
THEN ERROR(TOKEN&" is not a valid term in an expression");
GGTOKEN;
IF TOKEN≠"(" THEN ERROR("REQUIRE LEFT PAREN") ELSE GGTOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP; I2←I2 + 1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")" THEN ERROR("MISMATCHED PAREN") ELSE GGTOKEN(FALSE);
$$1←OPCODE(I,I2,$$1);
β
β "CASE TOKEN_INDEX";
[RES_TYPE]
IFC FALSE THENC [RES_TYPE]
IF TOKEN_INDEX=EVAL_X
THEN α RPTR(TREE) $TR; STRING S;RPTR(ANY_CLASS)TEMP;
EXPRESSION_STRING←EXPRESSION_STRING[1 TO ∞-4]&"{ "&TOKEN;
GGTOKEN;
IF TOKEN≠"(" THEN ERROR("REQUIRE LEFT PAREN")
ELSE $TR←GTEXPR;
$$1←MK_EXPR(TEMP←TREE:DATA[$TR],TREE:DTYPE[$TR]);
CASE TREE:DTYPE[$TR] OF
BEGIN "CASE"
[#SC] S← CVGX(SCALAR:VALUE[TEMP]);
[#VT] S← STR_VT(VECTOR:XC[TEMP],
VECTOR:YC[TEMP],(VECTOR:ZC[TEMP]),8);
[#RT] S←STR_RT(ROT:XF[TEMP]);
[#FR] S←"FRAME "&STR_TR(FRAME:XF[TEMP],1,8);
[#TR] S←STR_TR(TRANS:XF[TEMP],1,8)
END "CASE";
GGTOKEN;
IF TOKEN≠")" THEN ERROR("REQUIRE RIGHT PAREN")
ELSE
EXPRESSION_STRING←EXPRESSION_STRING&" = } "&S;
GGTOKEN(FALSE);
β
ELSE
ENDC
α I←TOKEN_INDEX; IF TOKEN_CLASS≠LEVEL
THEN ERROR(TOKEN&" is not a valid term in an expression");
GGTOKEN;
IF TOKEN≠"("
THEN ERROR("REQUIRE LEFT PAREN")
ELSE GGTOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP; I2←I2 + 1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")"
THEN ERROR("MISMATCHED PAREN")
ELSE GGTOKEN(FALSE);
$$1←OPCODE(I,I2,$$1);
β;
IFC FALSE THENC
[UNDECLARED_TYPE]
IF FN_CUR=NULL_RECORD THEN ERROR("UNEXPECTED TOKEN FOUND")
ELSE
α
INTEGER I;
FOR I←1 STEP 1 UNTIL FUNCTION:NARGS[FN_CUR]
DO IF EQU(TOKEN,FUNCTION:ARGNAME[FN_CUR][I])
THEN
α
$$1←MK_EXPR(FUNCTION:PTR[FN_CUR][I],#EX);
DONE;
β;
IF I> FUNCTION:NARGS[FN_CUR] THEN ERROR(TOKEN & " IS UNKNOWN");
GGTOKEN(FALSE);
β;
ENDC
ELSE α ERROR("UNEXPECTED TOKEN FOUND ⊂"&TOKEN&"⊃");
$$1←NEW_RECORD(!!EXPR);
β
β "CASE #TOKEN"
β;
RETURN($$1);
β;
! expression builders: hash,hashindex,new_expr,check_expr;
INTEGER PROCEDURE HASH(INTEGER OP; INTEGER ARRAY IX);
RETURN((((OP*#DTYPE + IX[1])*#DTYPE+IX[2])*#DTYPE +IX[3]));
INTEGER PROCEDURE HASHINDEX(INTEGER HASHVAL);
BEGIN
INTEGER INDEX,LB,UB;
LB←1;UB←#HASHTAB;
DO BEGIN
INDEX←(LB+UB)/2;
IF HASHTAB[INDEX]=HASHVAL THEN RETURN(INDEX)
ELSE IF HASHTAB[INDEX]>HASHVAL THEN UB←INDEX-1
ELSE LB←INDEX+1;
END UNTIL LB>UB;
RETURN(0);
END;
RPTR (!!EXPR) PROCEDURE NEW_EXPR(INTEGER OP; RPTR(!!EXPR) SON(NULL_RECORD),
BRO(NULL_RECORD),SELF(NULL_RECORD));
BEGIN
RPTR (!!EXPR) CUR;
IF SELF=NULL_RECORD THEN CUR←NEW_RECORD(!!EXPR) ELSE CUR←SELF;
!!EXPR:OP[CUR]←OP;
!!EXPR:SON[CUR]←SON;
!!EXPR:BRO[CUR]←BRO;
##EL←##EL + (!!EXPR:#EL[CUR]←1);
RETURN(CUR);
END;
INTEGER PROCEDURE CHECK_EXPR(INTEGER OP,NARGS; RPTR(!!EXPR)ARRAY EXPRRY);
BEGIN
COMMENT EXPPRY WILL BE OF SIZE [1:NARGS];
INTEGER I;
INTEGER ARRAY IX[1:3];
IF NARGS>3 THEN ERROR("More arguments for function "&CODE_OP[OP]&" than allowed");
ARRCLR(IX);
FOR I←1 STEP 1 UNTIL NARGS DO IX[I]←!!EXPR:TYPE[EXPRRY[I]];
I←HASHINDEX(HASH(OP,IX));
RETURN(I);
END;
! expression builders: opcode, idcode, cncode,arcode,prcode;
RPTR (!!EXPR) PROCEDURE OPCODE(INTEGER OP,NARGS; RPTR(!!EXPR)EPTR);
BEGIN
RPTR(!!EXPR)ARRAY EXPRRY[1:NARGS];
RPTR(!!EXPR) P1,P2;
INTEGER I;INTEGER PCODE_INDEX;
P1←EPTR;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN
EXPRRY[I]←P1;
P1←!!EXPR:BRO[P1];
END;
IF P1≠NULL_RECORD THEN ERROR("P1 should be null record");
IF (PCODE_INDEX←CHECK_EXPR(OP,NARGS,EXPRRY))=0
THEN BEGIN
STRING S; S←NULL;
FOR I←1 STEP 1 UNTIL NARGS DO
S←S&" "&DTYPES[!!EXPR:TYPE[EXPRRY[I]]]&",";
ERROR("operator/function "&CODE_OP[OP]&" cannot take operand(s)"&S[1 to ∞-1]);
END;
P1←NEW_RECORD(!!EXPR);
##EL←##EL + (!!EXPR:#EL[P1]←1);
!!EXPR:OP[P1]←PCODE[PCODE_INDEX];
!!EXPR:TYPE[P1]←OPTYPE[PCODE_INDEX];
!!EXPR:SON[P1]←EPTR;
RETURN(P1);
END;
RPTR (!!EXPR) PROCEDURE CNCODE(REAL VAL);
BEGIN "cncode"
COMMENT CODE TO HANDLE CONSTANTS;
RPTR(!!EXPR)E1;
E1←NEW_RECORD(!!EXPR);
##EL←##EL + (!!EXPR:#EL[E1]←3);
!!EXPR:TYPE[E1]←#SC;
!!EXPR:OP[E1]←XPUSHSCI;
FLTOUT(VAL,!!EXPR:X1[E1],!!EXPR:X2[E1]);
RETURN(E1);
END "cncode";
RPTR (!!EXPR) PROCEDURE IDCODE(RPTR(SYMBOL)SYMPTR);
BEGIN
! COMMENT CHANGE ID_OFFSET PART WHEN WE CAN DETERMINE ID_OFFSET DIRECTLY;
RPTR(!!EXPR)E1;
E1←NEW_RECORD(!!EXPR);
IF SYMBOL:INDEX[SYMPTR]>0 THEN
BEGIN "simply defined"
##EL←##EL + (!!EXPR:#EL[E1]←3);
!!EXPR:OP[E1]←XAGTVAL;
!!EXPR:X1[E1]←SYMBOL:INDEX[SYMPTR];
!!EXPR:X2[E1]←SYMBOL:OFFSET[SYMPTR];
END
ELSE BEGIN "for nonsimple symbols"
##EL←##EL+(!!EXPR:#EL[E1]←2);
!!EXPR:OP[E1]←XGTVAL;
!!EXPR:X1[E1]←SYMBOL:OFFSET[SYMPTR];
END;
!!EXPR:TYPE[E1]←SYMBOL:TYPE[SYMPTR];
RETURN(E1);
END;
RPTR(!!EXPR)PROCEDURE IDNDXCODE(RPTR(SYMBOL)PTR);
IF SYMBOL:INDEX[PTR]>0
THEN BEGIN RPTR(!!EXPR) E1;
E1←NEW_RECORD(!!EXPR);
!!EXPR:OP[E1]←XPUSHINTI;
!!EXPR:X1[E1]←SYMBOL:INDEX[PTR];
##EL←##EL+(!!EXPR:#EL[E1]←2);
RETURN(E1);
END
ELSE RETURN(NEW_EXPR(XNOOP));
RECURSIVE RPTR(!!EXPR)PROCEDURE ARNDXCODE(RPTR(SYMBOL)PTR);
BEGIN
! This procedure produces the tree form for the array
reference index. To get the full array reference
use arcode with the right argument GTVAL or CHNGE;
RPTR(!!EXPR)E2,E3;
INTEGER I;
GGTOKEN;
IF TOKEN≠"[" THEN ERROR("Need [ after array name");
GGTOKEN;
E2←EXP;
IF (E2=NULL_RECORD) OR (!!EXPR:TYPE[E2]≠#SC)
THEN ERROR("Index of Array must be scalar");
FOR I←2 STEP 1 UNTIL ARRAYREC:#DIM[SYMBOL:OBJECT[PTR]] DO
BEGIN
IF TOKEN≠"," THEN ERROR("Need comma between fields of array index");
GTOKEN;
IF ((E3←EXP)=NULL_RECORD) OR (!!EXPR:TYPE[E3]≠#SC)
THEN ERROR("Index of Array must be scalar");
!!EXPR:BRO[E3]←E2;
E2←E3;
END;
IF TOKEN≠"]" THEN ERROR("Need ] for bounds of array");
RETURN(E2);
END;
RECURSIVE RPTR(!!EXPR)PROCEDURE ARCODE(RPTR(SYMBOL)PTR; INTEGER OPERATION(XGTVAL));
BEGIN
RPTR(!!EXPR)E1;
IF (OPERATION≠XGTVAL) AND (OPERATION≠XCHNGE)
THEN ERROR("Error in ARCODE, OPERATION can take only XGTVAL or XCHNGE");
E1←NEW_RECORD(!!EXPR);
!!EXPR:OP[E1]←OPERATION;
!!EXPR:X1[E1]←SYMBOL:OFFSET[PTR];
!!EXPR:TYPE[E1]←SYMBOL:TYPE[PTR];
##EL←##EL+(!!EXPR:#EL[E1]←2);
!!EXPR:SON[E1]←ARNDXCODE(PTR);
RETURN(E1);
END;
RPTR(!!EXPR)PROCEDURE SPRCODE(RPTR(SYMBOL)PRSYM);
BEGIN
RPTR(!!EXPR)E1;
E1←NEW_RECORD(!!EXPR);
!!EXPR:OP[E1]←XPROC;
!!EXPR:X1[E1]←SYMBOL:OFFSET[PRSYM];
##EL←##EL+(!!EXPR:#EL[E1]←2);
RETURN(E1);
END;
RECURSIVE RPTR(!!EXPR)PROCEDURE PRCODE(RPTR(SYMBOL)PRSYM);
BEGIN "prcode"
INTEGER NARGS; RPTR(PROC)P;
RPTR(!!EXPR)EF;
NARGS←PROC:NARGS[P←SYMBOL:OBJECT[PRSYM]];
IF NARGS =0 THEN EF←SPRCODE(PRSYM)
ELSE BEGIN "procedure with arguments"
! E1,ETOP1 are pointers to the procedure call,
E0 refers to the arguments set up if they are values ;
RPTR(!!EXPR)E0,E1,ETOP1,ETMP,ETMP2; INTEGER I;
GGTOKEN;
IF TOKEN≠"(" THEN ERROR("Need open paren after procedure name "&SYMBOL:PNAME[PRSYM]);
ETOP1←E1←SPRCODE(PRSYM);
E0←NULL_RECORD;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN "check each argument"
GGTOKEN;
IF PROC:ARGACCS[P][I] LAND #ARRTYP THEN
BEGIN "array argument found"
IF TOKENPTR=NULL_RECORD
THEN ERROR("Need array reference here")
ELSE IF SYMBOL:ACCESS[TOKENPTR]≠#ARRAY
THEN ERROR("Need array reference here")
ELSE IF ARRAYREC:#DIM[SYMBOL:OBJECT[TOKENPTR]]
≠PROC:ARGDIM[P][I]
THEN ERROR("array dimensions dont agree with declaration");
!!EXPR:BRO[E1]←(ETMP←NEW_EXPR(SYMBOL:OFFSET[TOKENPTR]));
E1←ETMP;
END "array argument found"
ELSE BEGIN
ETMP←EXP;
IF NOT(!!EXPR:TYPE[ETMP] LAND PROC:ARGTYPE[P][I])
THEN ERROR("expression type does not agree with declaration");
IF (PROC:ARGACCS[P][I]=0) OR
(PROC:ARGACCS[P][I] LAND #REFTYP) AND
(!!EXPR:OP[ETMP]≠XAGTVAL) AND
(!!EXPR:OP[ETMP]≠XGTVAL)
THEN
BEGIN "value"
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
!!EXPR:BRO[E1]←(ETMP←NEW_EXPR(#MINUS1));
E1←ETMP; STOKEN←TRUE;
END "value"
ELSE BEGIN "reference"
IF !!EXPR:OP[ETMP]=XGTVAL THEN
BEGIN "xgtval"
ETMP2←NEW_EXPR(!!EXPR:X1[ETMP]);
!!EXPR:BRO[E1]←ETMP2;
E1←ETMP2;
ETMP←!!EXPR:SON[ETMP];
##EL←##EL-2;
IF ETMP THEN
BEGIN
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
END;
END "xgtval"
ELSE IF !!EXPR:OP[ETMP]=XAGTVAL
THEN
BEGIN "xagtval"
ETMP2←NEW_EXPR(!!EXPR:X2[ETMP]);
!!EXPR:BRO[E1]←ETMP2;
E1←ETMP2;
##EL←##EL-1;
!!EXPR:OP[ETMP]←XPUSHINTI;
!!EXPR:#EL[ETMP]←2;
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
END "xagtval"
ELSE ERROR("Disastrous error");
STOKEN←TRUE;
END "reference";
END;
GGTOKEN;
IF I<NARGS AND TOKEN≠"," THEN
BEGIN ERROR("Need comma between arguments"); GGTOKEN; END;
IF I=NARGS AND TOKEN≠")" THEN
ERROR("Need right paren after argument list");
END "check each argument";
EF←NEW_EXPR(XNOOP,NEW_EXPR(XNOOP,E0,ETOP1));
END "procedure with arguments";
!!EXPR:TYPE[EF]←SYMBOL:TYPE[PRSYM];
RETURN(EF);
END "prcode";
! checks that PRSYM points to a typed procedure ;
RECURSIVE RPTR(!!EXPR)PROCEDURE VPRCODE(RPTR(SYMBOL)PRSYM);
IF SYMBOL:TYPE[PRSYM]=#PR
THEN ERROR(SYMBOL:PNAME[PRSYM]&" cannot return a value and cannot be used here")
ELSE RETURN(PRCODE(PRSYM));
! mkexpr,gtexpr,aref,idref,pref;
RPTR(EXPR$) PROCEDURE MKEXPR(INTEGER BUFSIZ;RPTR(!!EXPR)EE);
BEGIN "MKEXPR"
! routine for changing the tree structure form of the expression into
an integer array.
The integer array is returned in EXPR$:BODY;
! Caution : the bro field of the expression EE should be null ;
INTEGER ARRAY BUFFER[1:BUFSIZ]; INTEGER Q; RPTR(EXPR$) $$;
PROCEDURE PUSHBUFFER(INTEGER I);
BUFFER[Q←Q+1]←I;
RECURSIVE PROCEDURE REDUCE(RPTR(!!EXPR)E);
BEGIN
RPTR(!!EXPR)E1;
E1←!!EXPR:SON[E];
WHILE E1≠NULL_RECORD DO
BEGIN REDUCE(E1);
E1←!!EXPR:BRO[E1];
END;
PUSHBUFFER(!!EXPR:OP[E]);
IF !!EXPR:#EL[E]=1 THEN RETURN;
PUSHBUFFER(!!EXPR:X1[E]);
IF !!EXPR:#EL[E]=2 THEN RETURN;
PUSHBUFFER(!!EXPR:X2[E]);
END;
Q←0;
REDUCE(EE);
IF Q≠BUFSIZ THEN ERROR("something is wrong, the string of numbers"&CVS(Q)&" not equal to expected"&CVS(BUFSIZ));
RETURN(αEXPR$(BUFFER,!!EXPR:TYPE[EE]));
END "MKEXPR";
RPTR(EXPR$)PROCEDURE GTEXPR;
BEGIN "GTEXPR"
! driver for MKEXPR;
RPTR(!!EXPR)EE;
##EL←0;
! STOKEN←FALSE;
GGTOKEN;
EE←EXP;
STOKEN←TRUE;
RETURN(MKEXPR(##EL,EE));
END "GTEXPR";
INTERNAL RPTR(EXPR$)PROCEDURE AREF(RPTR(SYMBOL)S;INTEGER OPERATION(XGTVAL));
BEGIN "AREF"
RPTR(!!EXPR)EE;
##EL←0;
EE←ARCODE(S,OPERATION);
RETURN(MKEXPR(##EL,EE));
END "AREF";
INTERNAL RPTR(EXPR$)PROCEDURE PREF(RPTR(SYMBOL)S);
BEGIN
RPTR(!!EXPR)EE;
##EL←0;
EE←PRCODE(S);
RETURN(MKEXPR(##EL,EE));
END;
! produces the EXPR$ record for references to variables
i.e. code to push the desired offset onto the stack ;
INTERNAL RPTR(EXPR$)PROCEDURE IDREF(REFERENCE RPTR(SYMBOL)S);
BEGIN "IDREF"
RPTR(!!EXPR)EE;
GGTOKEN;
IF TOKENPTR=NULL_RECORD THEN ERROR("Need identifier here")
ELSE S←TOKENPTR;
##EL←0;
EE←EXP;
IF !!EXPR:OP[EE]=XGTVAL THEN !!EXPR:OP[EE]←XPUSHOFFSET
ELSE IF !!EXPR:OP[EE]=XAGTVAL THEN !!EXPR:OP[EE]←XAPUSHOFFSET
ELSE ERROR("Need an identifier or array element here");
STOKEN←TRUE;
RETURN(MKEXPR(##EL,EE));
END "IDREF";
! buffer definitions, ipush,fpush,gpush,ppush,cpush;
INTEGER ARRAY $BUFFER[1:50];
INTEGER $BUFFERPTR;
! pushes integer J into the buffer ;
INTERNAL SIMPLE PROCEDURE IPUSH(INTEGER J);
$BUFFER[$BUFFERPTR←$BUFFERPTR+1]←J;
! pushes 11 representation of real value R into buffer ;
INTERNAL SIMPLE PROCEDURE FPUSH(REAL R);
BEGIN
FLTOUT(R,$BUFFER[$BUFFERPTR+1],$BUFFER[$BUFFERPTR+2]);
$BUFFERPTR←$BUFFERPTR+2;
END;
! pushes code to do a gtval ;
INTERNAL PROCEDURE GPUSH(RPTR(SYMBOL)S);
BEGIN INTEGER I;
IF SYMBOL:INDEX[S]>0
THEN FOR I←XAGTVAL,SYMBOL:INDEX[S],SYMBOL:OFFSET[S] DO IPUSH(I)
ELSE FOR I←XGTVAL,SYMBOL:OFFSET[S] DO IPUSH(I);
END;
INTERNAL PROCEDURE CPUSH(RPTR(SYMBOL)S);
BEGIN INTEGER I;
IF SYMBOL:INDEX[S]>0
THEN FOR I←XACHNGE,SYMBOL:INDEX[S],SYMBOL:OFFSET[S] DO IPUSH(I)
ELSE FOR I←XCHNGE,SYMBOL:OFFSET[S] DO IPUSH(I);
END;
INTERNAL PROCEDURE PPUSH(RPTR(SYMBOL)S);
IF SYMBOL:INDEX[S]>0 THEN
BEGIN IPUSH(XPUSHINTI);IPUSH(SYMBOL:INDEX[S]); END;
! αexpr$,βexpr$,nexpr,expr$11,expr$2,expr$off;
INTERNAL RPTR (EXPR$)PROCEDURE βEXPR$(INTEGER TYPE(0));
BEGIN
! creates a record EXPR$ with data from the buffer $BUFFER;
RPTR(EXPR$)EE; INTEGER ARRAY BUFF[1:$BUFFERPTR];
ARRBLT(BUFF[1],$BUFFER[1],$BUFFERPTR);
EE←NEW_RECORD(EXPR$);
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
EXPR$:#BODY[EE]←$BUFFERPTR;
EXPR$:TYPE[EE]←TYPE;
$BUFFERPTR←0;
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE NEXPR(INTEGER SIZE,ARG1);
BEGIN
! produces a record EXPR$ with #BODY=SIZE, and first element=ARG1;
INTEGER ARRAY BUFF[1:SIZE];
RPTR(EXPR$)EE;
BUFF[1]←ARG1;
EE←NEW_RECORD(EXPR$);
EXPR$:#BODY[EE]←SIZE;
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$1(INTEGER I(0));
RETURN(NEXPR(1,I));
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$2(INTEGER I(0),J(0));
BEGIN
RPTR(EXPR$)E;
E←NEXPR(2,I);
EXPR$:BODY[E][2]←J;
RETURN(E);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$3(INTEGER I(0),J(0),K(0));
BEGIN
RPTR(EXPR$)E;
E←NEXPR(3,I);
EXPR$:BODY[E][2]←J;
EXPR$:BODY[E][3]←K;
RETURN(E);
END;
INTERNAL INTEGER PROCEDURE EXPR$OFF(RPTR(EXPR$)ARRAY ARR; INTEGER I,J);
BEGIN
INTEGER K,K1;
K←1;
FOR K1←I STEP 1 UNTIL J DO IF ARR[K1] THEN K←K+EXPR$:#BODY[ARR[K1]];
RETURN(K);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$R(RPTR(SYMBOL)S);
IF SYMBOL:ACCESS[S]=#ARRAY_ELEMENT THEN
RETURN($APPEND(EXPR$G(S),EXPR$1(XRTVAL),SYMBOL:TYPE[S]))
ELSE
IF SYMBOL:INDEX[S]>0
THEN RETURN($APPEND(EXPR$2(XARTVAL,SYMBOL:INDEX[S]),
EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN RETURN($APPEND(EXPR$2(XGTVAL,SYMBOL:OFFSET[S]),
EXPR$1(XRTVAL),SYMBOL:TYPE[S]))
ELSE RETURN(EXPR$1(XNOOP));
INTERNAL RPTR(EXPR$) PROCEDURE EXPR$G(RPTR(SYMBOL)S);
IF SYMBOL:ACCESS[S]=#ARRAY_ELEMENT THEN
BEGIN
STRING S1; INTEGER I;
S1←SYMBOL:PNAME[S];
DO I←LOP(S1) UNTIL I="[";
DO BEGIN IPUSH(XPUSHINTI); IPUSH(INTSCAN(S1,I)); END UNTIL I="]";
FOR I←XGTVAL,SYMBOL:OFFSET[S] DO IPUSH(I);
RETURN(βEXPR$(SYMBOL:TYPE[S]));
END ELSE
IF SYMBOL:INDEX[S]>0
THEN RETURN($APPEND(EXPR$2(XAGTVAL,SYMBOL:INDEX[S]),
EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN RETURN($APPEND(EXPR$1(XGTVAL),EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE RETURN(EXPR$1(XNOOP));
INTERNAL RPTR (EXPR$) PROCEDURE αEXPR$(INTEGER ARRAY BUFFER;INTEGER #TYPE(0));
BEGIN
! creates a record EXPR$ with data the contents of BUFFER;
RPTR(EXPR$) EE; INTEGER I;
I←ARRINFO(BUFFER,2);
BEGIN
INTEGER ARRAY BUFF[1:I];
ARRTRAN(BUFF,BUFFER);
EE←NEW_RECORD(EXPR$);
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
EXPR$:#BODY[EE]←I;
END;
EXPR$:TYPE[EE]←#TYPE;
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$ID(RPTR(SYMBOL)S);
IF SYMBOL:ACCESS[S]≠#SIMPLE THEN ERROR("EXPR$ID must take simple argument")
ELSE IF SYMBOL:INDEX[S]>0 THEN
RETURN($APPEND(EXPR$2(XAPUSHOFFSET,SYMBOL:INDEX[S]),
EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN RETURN($APPEND(EXPR$1(XPUSHINTI),EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S]))
ELSE RETURN(EXPR$1(XNOOP));
! $append,$aappend;
INTERNAL RPTR(EXPR$) PROCEDURE $APPEND(RPTR(EXPR$)E1,E2; INTEGER TYPE(0));
BEGIN
! produces a new record concatenating the bodies of the E1 and E2;
RPTR(EXPR$)EE; INTEGER J1,J2,J;
IF E1 THEN J1←EXPR$:#BODY[E1] ELSE J1←0;
IF E2 THEN J2←EXPR$:#BODY[E2] ELSE J2←0;
J←J1+J2;
IF J>0 THEN
BEGIN INTEGER ARRAY BUFF[1:J];
IF J1 THEN ARRBLT(BUFF[1],EXPR$:BODY[E1][1],J1);
IF J2 THEN ARRBLT(BUFF[J1+1],EXPR$:BODY[E2][1],J2);
EE←αEXPR$(BUFF,TYPE);
EXPR$:#BODY[EE]←J;
END;
RETURN(EE);
END;
INTERNAL RPTR(EXPR$) PROCEDURE $AAPPEND(RPTR(EXPR$) ARRAY APTR;INTEGER TYPE(0));
BEGIN RPTR(EXPR$) PTR;
INTEGER LA,UA; LA←ARRINFO(APTR,1); UA←ARRINFO(APTR,2);
BEGIN INTEGER I,BSIZE; INTEGER ARRAY ASIZE[LA:UA];
BSIZE←0;
FOR I←LA STEP 1 UNTIL UA DO
IF APTR[I] THEN
BSIZE←BSIZE + (ASIZE[I]←EXPR$:#BODY[APTR[I]]);
BEGIN
INTEGER ARRAY BUFF[1:BSIZE]; INTEGER J1;
J1←1;
FOR I←LA STEP 1 UNTIL UA DO
IF ASIZE[I]>0 THEN
BEGIN
ARRBLT(BUFF[J1],EXPR$:BODY[APTR[I]][1],ASIZE[I]);
J1←J1+ASIZE[I];
END;
PTR←NEW_RECORD(EXPR$);
MEMORY[LOCATION(BUFF)] ↔ MEMORY[LOCATION(EXPR$:BODY[PTR])];
EXPR$:#BODY[PTR]←BSIZE;
END;
END;
EXPR$:TYPE[PTR]←TYPE;
RETURN(PTR);
END;
! $$gtidref,$$gtanyexp;
! returns code to push offset of id on stack - type must
be the same, else does not return, unless type=0 ;
INTERNAL RPTR(EXPR$) PROCEDURE $$GTIDREF(INTEGER TYPE;
REFERENCE RPTR(SYMBOL)SYM; STRING S);
BEGIN
RPTR(EXPR$)E;
E←IDREF(SYM);
IF TYPE≠0 AND EXPR$:TYPE[E]≠TYPE THEN
IF TYPE=#FR AND EXPR$:TYPE[E]=#TR
THEN
BEGIN STRING S1; S1←SYMBOL:PNAME[SYM];
! SYM←FRAME:SYM[BELONGS(S1,#FR)] ; END
ELSE
ERROR("Id type found does not agree with expected type in "&S);
RETURN(E);
END;
! returns an expr of indicated type or doesnt return at all;
INTERNAL RPTR(EXPR$) PROCEDURE $$GTANYEXP(STRING S;INTEGER TYPE);
BEGIN
RPTR(EXPR$)E; INTEGER TYPEF;
TYPEF←EXPR$:TYPE[E←$$GTEXPR];
IF (TYPEF=#TR AND TYPE=#FR) OR (TYPEF=#FR AND TYPE=#TR) THEN RETURN(E);
IF TYPEF≠TYPE
THEN
CASE TYPE OF
BEGIN
[#SC] ERROR("Need scalar expression for ",S);
[#VT] ERROR("Need vector expression for ",S);
[#RT] ERROR("Need rot expression for ",S);
[#TR][#FR] ERROR("Need trans or frame expression for ",S)
END;
RETURN(E);
END;
! $$gtexpr,$$gtvexpr;
INTERNAL RPTR(EXPR$) PROCEDURE $$GTEXPR;
RETURN(GTEXPR);
INTERNAL RECURSIVE RPTR(EXPR$) PROCEDURE $$GTVEXPR;
RETURN($ELFEVAL(GTEXPR));
END "EXPR";